經典網頁App分享

林嶔 (Lin, Chin)

Lesson 16

第一節:創造互動式圖形(1)

– ui.R

library(shiny)

fluidPage(
  fluidRow(
    column(width = 4,
           plotOutput("plot1", height = 350,
                      click = "plot_click",
                      dblclick = dblclickOpts(id = "plot_dblclick"),
                      hover = hoverOpts(id = "plot_hover"),
                      brush = brushOpts(id = "plot_brush")
           )
    )
  ),
  fluidRow(
    column(width = 3,
           verbatimTextOutput("click_info")
    ),
    column(width = 3,
           verbatimTextOutput("dblclick_info")
    ),
    column(width = 3,
           verbatimTextOutput("hover_info")
    ),
    column(width = 3,
           verbatimTextOutput("brush_info")
    )
  )
)

– server.R

library(shiny)

data(cars)
dat = cars

shinyServer(function(input, output) {
  output$plot1 <- renderPlot({
    plot(dat)
  })
  
  output$click_info <- renderPrint({
    cat("input$plot_click:\n")
    str(input$plot_click)
  })
  output$hover_info <- renderPrint({
    cat("input$plot_hover:\n")
    str(input$plot_hover)
  })
  output$dblclick_info <- renderPrint({
    cat("input$plot_dblclick:\n")
    str(input$plot_dblclick)
  })
  output$brush_info <- renderPrint({
    cat("input$plot_brush:\n")
    str(input$plot_brush)
  })
  
})

第一節:創造互動式圖形(2)

– 這邊需要用到兩個新函數:reactiveValues()、observe()和observeEvent()

library(shiny)

fluidPage(
  fluidRow(
    column(width = 4,
           plotOutput("plot1", height = 400,
                      brush = brushOpts(id = "plot1_brush", resetOnNew = TRUE))
    ),
    column(width = 4,
           plotOutput("plot2", height = 400)
    ),
    column(width = 4,
           plotOutput("plot3", height = 400,
                      dblclick = "plot3_dblclick",
                      brush = brushOpts(id = "plot3_brush", resetOnNew = TRUE))
    )
  )
)
library(shiny)

data(cars)
dat = cars

shinyServer(function(input, output) {
  
  ranges1 = reactiveValues(x = NULL, y = NULL)
  
  observe({
    brush1 = input$plot1_brush
    if (!is.null(brush1)) {
      ranges1$x = c(brush1$xmin, brush1$xmax)
      ranges1$y = c(brush1$ymin, brush1$ymax)
    } else {
      ranges1$x = NULL
      ranges1$y = NULL
    }
  })
  
  output$plot1 <- renderPlot({
    plot(dat)
  })
  
  output$plot2 <- renderPlot({
    plot(dat, xlim = ranges1$x, ylim = ranges1$y)
  })
  
  ranges2 <- reactiveValues(x = NULL, y = NULL)
  
  output$plot3 <- renderPlot({
    plot(dat, xlim = ranges2$x, ylim = ranges2$y)
  })
  
  observeEvent(input$plot3_dblclick, {
    brush2 <- input$plot3_brush
    if (!is.null(brush2)) {
      ranges2$x <- c(brush2$xmin, brush2$xmax)
      ranges2$y <- c(brush2$ymin, brush2$ymax)
    } else {
      ranges2$x <- NULL
      ranges2$y <- NULL
    }
  })
  
})

練習1:手動標註系統(1)

– 我們先看看裡面的一個文字檔案,而這個檔案描述的是5張圖的人類位置在哪:

box_info = read.csv("examples/label.csv", header = TRUE, stringsAsFactors = FALSE)
box_info
##    obj_name   col_left col_right   row_bot   row_top prob img_id
## 1    person 0.60728125 0.7782344 0.8139110 0.1637471    1      1
## 2    person 0.00000000 0.0971250 0.7015925 0.6154801    1      1
## 3    person 0.50981250 0.6211250 0.8687150 0.4078505    1      2
## 4    person 0.01529687 0.2058281 0.9194159 0.3903271    1      2
## 5    person 0.79756250 0.9907812 0.9042757 0.4001636    1      2
## 6    person 0.32854688 0.6720156 0.8738333 0.2985208    1      3
## 7    person 0.88721875 0.9362500 0.7515368 0.5911255    1      4
## 8    person 0.39248437 0.4289219 0.3639394 0.2303463    1      4
## 9    person 0.47934375 0.4961250 0.6005000 0.5788542    1      5
## 10   person 0.76668750 0.7721250 0.5681875 0.5610833    1      5

練習1:手動標註系統(2)

library(jpeg)
library(imager)

Show_img = function (img, box_info = NULL, col_bbox = '#FFFFFF00', col_label = '#FF0000FF') {
  
  par(mar = rep(0, 4))
  plot(NA, xlim = c(0, 1), ylim = c(1, 0), xaxt = "n", yaxt = "n", bty = "n")
  img = (img - min(img))/(max(img) - min(img))
  img = as.raster(img)
  rasterImage(img, 0, 1, 1, 0, interpolate=FALSE)
  
  
  if (!is.null(box_info)) {
    if (nrow(box_info) > 0) {
      for (i in 1:nrow(box_info)) {
        size = max(box_info[i,3] - box_info[i,2], 0.2)
        rect(xleft = box_info[i,2], xright = box_info[i,2] + 0.06*sqrt(size)*nchar(box_info[i,1]),
             ybottom = box_info[i,5] + 0.08*sqrt(size), ytop = box_info[i,5],
             col = col_label, border = col_label, lwd = 0)
        text(x = box_info[i,2] + 0.03*sqrt(size) * nchar(box_info[i,1]),
             y = box_info[i,5] + 0.04*sqrt(size),
             labels = box_info[i,1],
             col = 'white', cex = 1.5*sqrt(size), font = 2)
        rect(xleft = box_info[i,2], xright = box_info[i,3],
             ybottom = box_info[i,4], ytop = box_info[i,5],
             col = col_bbox, border = col_label, lwd = 5*sqrt(size))
      }
    }
  }
  
}
img = readJPEG("examples/2.jpeg")
Show_img(img, box_info[box_info[,"img_id"] == 2,])

img = readJPEG("examples/3.jpeg")
Show_img(img, box_info[box_info[,"img_id"] == 3,])

練習1:手動標註系統(3)

  1. 讓使用者能夠自己上傳一張圖片上去

  2. 框出物件的位置在哪,並選擇框選的物件為何(目前只有人類供選擇)

  3. 按下按鍵後紀錄框的位置

  4. 將資訊記錄在資料表內,而img_id設定為圖像的檔名

  5. 如果使用者覺得框錯了,可以把它刪除

  6. 使用者最終能下載該資料表

練習1答案

library(shiny)
library(DT)
library(jpeg)
library(imager)

fluidPage(
  fluidRow(
    column(width = 4,
           fileInput("files", label = h4("Upload your jpeg image:"), multiple = FALSE, accept = "image/jpeg"),
           br(),
           radioButtons("obj", label = h4("Please select a object name:"), c("person" = "person")),
           br(),
           downloadButton("download", label = "Download file", class = NULL)
    ),
    column(width = 7,
           plotOutput("plot", height = 416, width = 416,
                      dblclick = "plot_dblclick",
                      brush = brushOpts(id = "plot_brush", resetOnNew = TRUE)),
           br(),
           actionButton("delete", strong("Delete selected box!"), icon("list-alt")),
           br(),
           br(),
           DT::dataTableOutput('table')
    )
  )
)
library(shiny)
library(DT)
library(jpeg)
library(imager)

Show_img = function (img, box_info = NULL, col_bbox = '#FFFFFF00', col_label = '#FF0000FF') {
  
  par(mar = rep(0, 4))
  plot(NA, xlim = c(0, 1), ylim = c(1, 0), xaxt = "n", yaxt = "n", bty = "n")
  img = (img - min(img))/(max(img) - min(img))
  img = as.raster(img)
  rasterImage(img, 0, 1, 1, 0, interpolate=FALSE)
  
  
  if (!is.null(box_info)) {
    if (nrow(box_info) > 0) {
      for (i in 1:nrow(box_info)) {
        size = max(box_info[i,3] - box_info[i,2], 0.2)
        rect(xleft = box_info[i,2], xright = box_info[i,2] + 0.06*sqrt(size)*nchar(box_info[i,1]),
             ybottom = box_info[i,5] + 0.08*sqrt(size), ytop = box_info[i,5],
             col = col_label, border = col_label, lwd = 0)
        text(x = box_info[i,2] + 0.03*sqrt(size) * nchar(box_info[i,1]),
             y = box_info[i,5] + 0.04*sqrt(size),
             labels = box_info[i,1],
             col = 'white', cex = 1.5*sqrt(size), font = 2)
        rect(xleft = box_info[i,2], xright = box_info[i,3],
             ybottom = box_info[i,4], ytop = box_info[i,5],
             col = col_bbox, border = col_label, lwd = 5*sqrt(size))
      }
    }
  }
  
}

shinyServer(function(input, output) {
  
  IMAGE = reactive({
    if (is.null(input$files)) {return()} else {
      img = readJPEG(input$files$datapath)
      return(img) 
    }
  })
  
  MY_TABLE = reactiveValues(table = NULL)
  
  output$plot = renderPlot({
    img = IMAGE()
    if (!is.null(input$files$name)) {
      box_info = MY_TABLE$table
      box_info = box_info[box_info[,"img_id"] == input$files$name,]
    } else {
      box_info = NULL
    }
    if (is.null(img)) {return()} else {
      Show_img(img = img, box_info = box_info)
    }
  })
  
  observeEvent(input$plot_dblclick, {
    brush = input$plot_brush
    if (!is.null(brush) & !is.null(input$files$name)) {
      new_table = data.frame(obj_name = input$obj,
                             col_left = brush$xmin,
                             col_right = brush$xmax,
                             row_bot = brush$ymax,
                             row_top = brush$ymin,
                             prob = 1,
                             img_id = input$files$name,
                             stringsAsFactors = FALSE)
      MY_TABLE$table = rbind(MY_TABLE$table, new_table)
    }
  })
  
  observeEvent(input$delete, {
    selection = as.numeric(input$table_rows_selected)
    if (length(selection)!=0) {
      MY_TABLE$table = MY_TABLE$table[-selection,]
    }
  })
  
  output$table = DT::renderDataTable({
    dat = MY_TABLE$table
    if (is.null(dat)) {return()} else {
      dat[,2] = round(dat[,2], 3)
      dat[,3] = round(dat[,3], 3)
      dat[,4] = round(dat[,4], 3)
      dat[,5] = round(dat[,5], 3)
      Result = DT::datatable(dat)
      return(Result)
    }
  })
  
  output$download = downloadHandler(
    filename = function() {'label.csv'},
    content = function(con) {
      dat = MY_TABLE$table
      if (is.null(dat)) {return()} else {
        write.csv(dat, con, row.names = FALSE)
      }
    }
  )
  
  
})

第二節:學習如何套用別人寫好的程式(1)

– 你應該有注意到你的App是沒有辦法用帳號密碼保護的,而要做這件事情確實是有難度,畢竟我們似乎是沒有學過兩個頁面的切換功能,那讓我們再google看看吧:

F16_5

– 其中的第三個討論串:Starting Shiny app after password input就是在講這件事情

F16_6

第二節:學習如何套用別人寫好的程式(2)

rm(list = ls())
library(shiny)

Logged = FALSE;
my_username <- "test"
my_password <- "test"

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),actionButton("Login", "Log in"))),
    tags$style(type="text/css", "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
  )}

ui2 <- function(){tagList(tabPanel("Test"))}

ui = (htmlOutput("page"))
server = (function(input, output,session) {

  USER <- reactiveValues(Logged = Logged)

  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            } 
          }
        } 
      }
    }    
  })
  observe({
    if (USER$Logged == FALSE) {

      output$page <- renderUI({
        div(class="outer",do.call(bootstrapPage,c("",ui1())))
      })
    }
    if (USER$Logged == TRUE) 
    {
      output$page <- renderUI({
        div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })
      print(ui)
    }
  })
})

runApp(list(ui = ui, server = server))

第二節:學習如何套用別人寫好的程式(3)

– global.R

library(shiny)

Logged = FALSE;
my_username <- "test"
my_password <- "test"

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),actionButton("Login", "Log in"))),
    tags$style(type="text/css", "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
  )}

ui2 <- function(){tagList(tabPanel("Test"))}

– ui.R

library(shiny)

htmlOutput("page")
library(shiny)

function(input, output,session) {

  USER <- reactiveValues(Logged = Logged)

  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            } 
          }
        } 
      }
    }    
  })
  observe({
    if (USER$Logged == FALSE) {

      output$page <- renderUI({
        div(class="outer",do.call(bootstrapPage,c("",ui1())))
      })
    }
    if (USER$Logged == TRUE) 
    {
      output$page <- renderUI({
        div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })
      print(ui)
    }
  })
}

第二節:學習如何套用別人寫好的程式(4)

– global.R

library(shiny)

Logged = FALSE;
my_username <- "test"
my_password <- "test"

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),actionButton("Login", "Log in"))),
    tags$style(type="text/css", "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
  )}

ui2 <- function(){tagList(tabPanel("Test",
                                   sliderInput("obs", "Number of observations:", min = 0, max = 1000, value = 500),
                                   plotOutput("distPlot")))}

– ui.R

library(shiny)

htmlOutput("page")
library(shiny)

function(input, output,session) {
  
  USER <- reactiveValues(Logged = Logged)
  
  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            } 
          }
        } 
      }
    }    
  })
  observe({
    if (USER$Logged == FALSE) {
      
      output$page <- renderUI({
        div(class="outer",do.call(bootstrapPage,c("",ui1())))
      })
    }
    if (USER$Logged == TRUE) 
    {
      output$page <- renderUI({
        div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })
      print(ui)
      
      output$distPlot = renderPlot({
        
        # generate an rnorm distribution and plot it
        dist = rnorm(input$obs)
        hist(dist)
      })
      
    }
  })
}

練習2:讓剛剛的標註系統上增加帳號密碼的輸入

– 請你設計兩個頁面的程序,讓使用者在使用標註系統之前需要輸入帳號密碼!

練習2答案

library(shiny)
library(DT)
library(jpeg)
library(imager)

Logged = FALSE;
my_username <- "test"
my_password <- "test"

Show_img = function (img, box_info = NULL, col_bbox = '#FFFFFF00', col_label = '#FF0000FF') {
  
  par(mar = rep(0, 4))
  plot(NA, xlim = c(0, 1), ylim = c(1, 0), xaxt = "n", yaxt = "n", bty = "n")
  img = (img - min(img))/(max(img) - min(img))
  img = as.raster(img)
  rasterImage(img, 0, 1, 1, 0, interpolate=FALSE)
  
  
  if (!is.null(box_info)) {
    if (nrow(box_info) > 0) {
      for (i in 1:nrow(box_info)) {
        size = max(box_info[i,3] - box_info[i,2], 0.2)
        rect(xleft = box_info[i,2], xright = box_info[i,2] + 0.06*sqrt(size)*nchar(box_info[i,1]),
             ybottom = box_info[i,5] + 0.08*sqrt(size), ytop = box_info[i,5],
             col = col_label, border = col_label, lwd = 0)
        text(x = box_info[i,2] + 0.03*sqrt(size) * nchar(box_info[i,1]),
             y = box_info[i,5] + 0.04*sqrt(size),
             labels = box_info[i,1],
             col = 'white', cex = 1.5*sqrt(size), font = 2)
        rect(xleft = box_info[i,2], xright = box_info[i,3],
             ybottom = box_info[i,4], ytop = box_info[i,5],
             col = col_bbox, border = col_label, lwd = 5*sqrt(size))
      }
    }
  }
  
}

ui1 <- function(){
  tagList(
    div(id = "login",
        wellPanel(textInput("userName", "Username"),
                  passwordInput("passwd", "Password"),
                  br(),actionButton("Login", "Log in"))),
    tags$style(type="text/css", "#login {font-size:10px;   text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
  )}

ui2 <- function(){tagList(tabPanel("Main page",
                                   fluidRow(
                                     column(width = 4,
                                            fileInput("files", label = h4("Upload your jpeg image:"), multiple = FALSE, accept = "image/jpeg"),
                                            br(),
                                            radioButtons("obj", label = h4("Please select a object name:"), c("person" = "person")),
                                            br(),
                                            downloadButton("download", label = "Download file", class = NULL)
                                     ),
                                     column(width = 7,
                                            plotOutput("plot", height = 416, width = 416,
                                                       dblclick = "plot_dblclick",
                                                       brush = brushOpts(id = "plot_brush", resetOnNew = TRUE)),
                                            br(),
                                            actionButton("delete", strong("Delete selected box!"), icon("list-alt")),
                                            br(),
                                            br(),
                                            DT::dataTableOutput('table')
                                     )
                                   )))}
library(shiny)
library(DT)
library(jpeg)
library(imager)

htmlOutput("page")
library(shiny)
library(DT)
library(jpeg)
library(imager)

function(input, output,session) {
  
  USER <- reactiveValues(Logged = Logged)
  
  observe({ 
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(my_username == Username)
          Id.password <- which(my_password == Password)
          if (length(Id.username) > 0 & length(Id.password) > 0) {
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            } 
          }
        } 
      }
    }    
  })
  observe({
    if (USER$Logged == FALSE) {
      
      output$page <- renderUI({
        div(class="outer",do.call(bootstrapPage,c("",ui1())))
      })
    }
    if (USER$Logged == TRUE) 
    {
      output$page <- renderUI({
        div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
      })
      print(ui)
      
      IMAGE = reactive({
        if (is.null(input$files)) {return()} else {
          img = readJPEG(input$files$datapath)
          return(img) 
        }
      })
      
      MY_TABLE = reactiveValues(table = NULL)
      
      output$plot = renderPlot({
        img = IMAGE()
        if (!is.null(input$files$name)) {
          box_info = MY_TABLE$table
          box_info = box_info[box_info[,"img_id"] == input$files$name,]
        } else {
          box_info = NULL
        }
        if (is.null(img)) {return()} else {
          Show_img(img = img, box_info = box_info)
        }
      })
      
      observeEvent(input$plot_dblclick, {
        brush = input$plot_brush
        if (!is.null(brush) & !is.null(input$files$name)) {
          new_table = data.frame(obj_name = input$obj,
                                 col_left = brush$xmin,
                                 col_right = brush$xmax,
                                 row_bot = brush$ymax,
                                 row_top = brush$ymin,
                                 prob = 1,
                                 img_id = input$files$name,
                                 stringsAsFactors = FALSE)
          MY_TABLE$table = rbind(MY_TABLE$table, new_table)
        }
      })
      
      observeEvent(input$delete, {
        selection = as.numeric(input$table_rows_selected)
        if (length(selection)!=0) {
          MY_TABLE$table = MY_TABLE$table[-selection,]
        }
      })
      
      output$table = DT::renderDataTable({
        dat = MY_TABLE$table
        if (is.null(dat)) {return()} else {
          dat[,2] = round(dat[,2], 3)
          dat[,3] = round(dat[,3], 3)
          dat[,4] = round(dat[,4], 3)
          dat[,5] = round(dat[,5], 3)
          Result = DT::datatable(dat)
          return(Result)
        }
      })
      
      output$download = downloadHandler(
        filename = function() {'label.csv'},
        content = function(con) {
          dat = MY_TABLE$table
          if (is.null(dat)) {return()} else {
            write.csv(dat, con, row.names = FALSE)
          }
        }
      )
      
    }
  })
}

第三節:Case study-網路爬蟲程式(1)

– 想要找的話你可以複製貼上下面的程式碼:

library(rvest)

my_table = matrix("", nrow = 10, ncol = 4)
colnames(my_table) = c("Title", "url", "ID", "time")

URL = "https://www.ptt.cc/bbs/AllTogether/index.html"
current_id = 1

for (i in 1:10) {
  
  website = read_html(URL)
  needed_html = website %>% html_nodes("a")
  needed_txt = needed_html %>% html_text()
  intrested_pos = grep("[徵男]", needed_txt, fixed = TRUE)
  
  if (length(intrested_pos) > 0) {
    
    for (j in intrested_pos) {
      
      if (current_id <= 10) {
        my_table[current_id, 1] = needed_txt[j]
        my_table[current_id, 2] = needed_html[j] %>% html_attr("href")
      }
      
    current_id = current_id + 1
    
    }
    
  }
  
  if (current_id > 10) {
    break
  }
  
  next_page = website %>% html_nodes("a") %>% .[8] %>% html_attr("href")
  URL = paste0("https://www.ptt.cc", next_page, sep = "")
  
}

for (i in 1:nrow(my_table)) {
  
  sub_URL = paste("https://www.ptt.cc", my_table[i, 2], sep = "")
  sub_website = read_html(sub_URL)
  article_info = sub_website %>% html_nodes(".article-meta-value") %>% html_text()
  my_table[i, 3] = article_info[1]
  my_table[i, 4] = article_info[4]
  
}

my_table
##       Title                          
##  [1,] "[徵男] 一起放假惹"            
##  [2,] "[徵男] 我喜歡簡簡單單,你呢?"
##  [3,] "[徵男] 你認識耶穌嗎?"        
##  [4,] "[徵男] 52赫茲"                
##  [5,] "[徵男] 週末一起火鍋"          
##  [6,] "[徵男] 我有咖啡你有故事嗎"    
##  [7,] "[徵男] 先從順眼的朋友開始吧"  
##  [8,] "[徵男] 高雄 明天下午來吃冰"   
##  [9,] "[徵男] 其實,還是期待中"      
## [10,] "[徵男] 天氣好就上山啦"        
##       url                                       
##  [1,] "/bbs/AllTogether/M.1536885950.A.55E.html"
##  [2,] "/bbs/AllTogether/M.1536853001.A.ADC.html"
##  [3,] "/bbs/AllTogether/M.1536853491.A.120.html"
##  [4,] "/bbs/AllTogether/M.1536837758.A.BF4.html"
##  [5,] "/bbs/AllTogether/M.1536824986.A.A9C.html"
##  [6,] "/bbs/AllTogether/M.1536814579.A.E28.html"
##  [7,] "/bbs/AllTogether/M.1536771465.A.06C.html"
##  [8,] "/bbs/AllTogether/M.1536772243.A.E2C.html"
##  [9,] "/bbs/AllTogether/M.1536763374.A.310.html"
## [10,] "/bbs/AllTogether/M.1536765971.A.82E.html"
##       ID                         time                      
##  [1,] "desserthsuan (喜歡看海~)" "Fri Sep 14 08:45:48 2018"
##  [2,] "exotic0714 (exotic)"      "Thu Sep 13 23:36:39 2018"
##  [3,] "needideas (需要靈感)"     "Thu Sep 13 23:44:48 2018"
##  [4,] "hhgirl (咦?)"             "Thu Sep 13 19:22:35 2018"
##  [5,] "forthenight (MUSIQ)"      "Thu Sep 13 15:49:43 2018"
##  [6,] "ayayamamiri (小貓咪)"     "Thu Sep 13 12:56:16 2018"
##  [7,] "enzo823 (Enzo)"           "Thu Sep 13 00:57:42 2018"
##  [8,] "yijilin (初悸)"           "Thu Sep 13 01:10:40 2018"
##  [9,] "YVNNEY (從我變成我們)"    "Wed Sep 12 22:42:51 2018"
## [10,] "CA81 (CA)"                "Wed Sep 12 23:26:08 2018"

第三節:Case study-網路爬蟲程式(2)

library(shiny)
library(rvest)

shinyUI(navbarPage("徵男文自動尋找系統",
                   tabPanel("近期文章搜尋",
                            actionButton("submit", strong("按我開始找")),
                            br(),
                            DT::dataTableOutput("view")
                   )
))
library(shiny)
library(rvest)

shinyServer(function(input, output) {
  
  MY_TABLE = eventReactive(input$submit, {
    
    my_table = matrix("", nrow = 10, ncol = 4)
    colnames(my_table) = c("Title", "url", "ID", "time")
    
    URL = "https://www.ptt.cc/bbs/AllTogether/index.html"
    current_id = 1
    
    withProgress(message = "尋找文章中...", value = 0, {
    
      for (i in 1:10) {
        
        website = read_html(URL)
        needed_html = website %>% html_nodes("a")
        needed_txt = needed_html %>% html_text()
        intrested_pos = grep("[徵男]", needed_txt, fixed = TRUE)
        
        if (length(intrested_pos) > 0) {
          
          for (j in intrested_pos) {
            
            if (current_id <= 10) {
              my_table[current_id, 1] = needed_txt[j]
              my_table[current_id, 2] = needed_html[j] %>% html_attr("href")
            }
            
            current_id = current_id + 1
            
          }
          
        }
        
        if (current_id > 10) {
          break
        }
        
        next_page = website %>% html_nodes("a") %>% .[8] %>% html_attr("href")
        URL = paste0("https://www.ptt.cc", next_page, sep = "")
        
        incProgress(1/10)
        
      }
      
    })
    
    withProgress(message = "擷取文章資訊中...", value = 0, {
      
      for (i in 1:nrow(my_table)) {
        
        sub_URL = paste("https://www.ptt.cc", my_table[i, 2], sep = "")
        sub_website = read_html(sub_URL)
        article_info = sub_website %>% html_nodes(".article-meta-value") %>% html_text()
        my_table[i, 3] = article_info[1]
        my_table[i, 4] = article_info[4]
        
        incProgress(1/nrow(my_table))
        
      }
      
    })
    
    my_table
    
  })
  
  output$view = DT::renderDataTable({
    dat = MY_TABLE()
    if (is.null(dat)) {return()} else {
      dat = data.frame(dat, stringsAsFactors = FALSE)
      Result = DT::datatable(dat)
      return(Result)
    }
  })
  
})

第三節:Case study-網路爬蟲程式(3)

– 這裡我們會用到一些HTML的語法,還記得超連結的標籤是什麼嗎?

library(shiny)
library(rvest)

shinyUI(navbarPage("徵男文自動尋找系統",
                   tabPanel("近期文章搜尋",
                            actionButton("submit", strong("按我開始找")),
                            br(),
                            DT::dataTableOutput("view")
                   )
))
library(shiny)
library(rvest)

shinyServer(function(input, output) {
  
  MY_TABLE = eventReactive(input$submit, {
    
    my_table = matrix("", nrow = 10, ncol = 4)
    colnames(my_table) = c("Title", "url", "ID", "time")
    
    URL = "https://www.ptt.cc/bbs/AllTogether/index.html"
    current_id = 1
    
    withProgress(message = "尋找文章中...", value = 0, {
    
      for (i in 1:10) {
        
        website = read_html(URL)
        needed_html = website %>% html_nodes("a")
        needed_txt = needed_html %>% html_text()
        intrested_pos = grep("[徵男]", needed_txt, fixed = TRUE)
        
        if (length(intrested_pos) > 0) {
          
          for (j in intrested_pos) {
            
            if (current_id <= 10) {
              my_table[current_id, 1] = needed_txt[j]
              my_table[current_id, 2] = needed_html[j] %>% html_attr("href")
            }
            
            current_id = current_id + 1
            
          }
          
        }
        
        if (current_id > 10) {
          break
        }
        
        next_page = website %>% html_nodes("a") %>% .[8] %>% html_attr("href")
        URL = paste0("https://www.ptt.cc", next_page, sep = "")
        
        incProgress(1/10)
        
      }
      
    })
    
    withProgress(message = "擷取文章資訊中...", value = 0, {
      
      for (i in 1:nrow(my_table)) {
        
        sub_URL = paste("https://www.ptt.cc", my_table[i, 2], sep = "")
        sub_website = read_html(sub_URL)
        article_info = sub_website %>% html_nodes(".article-meta-value") %>% html_text()
        my_table[i, 3] = article_info[1]
        my_table[i, 4] = article_info[4]
        
        incProgress(1/nrow(my_table))
        
      }
      
    })
    
    my_table
    
  })
  
  output$view = DT::renderDataTable({
    dat = MY_TABLE()
    if (is.null(dat)) {return()} else {
      dat = data.frame(dat, stringsAsFactors = FALSE)
      dat[,2] = paste('<a href="https://www.ptt.cc', dat[,2], '">', dat[,2], '</a>', sep = "")
      Result = DT::datatable(dat, escape = FALSE)
      return(Result)
    }
  })
  
})

小結

– 關於使用shiny套件的學習資源,可以參考shiny的官方網站

– 如果你想多看看別人寫的shiny應用程式,你可以到shiny gallery去學習學習!

– 但注意,免費帳戶每月僅能讓App運作25小時,並且只能上傳5個App

– 除此之外,如果你的原始碼有重要的商業價值,建議還是自建server

分享你的App至shinyapps.io

install.packages("devtools")
library(devtools)
devtools::install_github('rstudio/shinyapps')
library(shinyapps)

建立R與你的帳戶的聯結

F16_1

F16_2

F16_3

分享

– 點選Publish後,會出現個小視窗,指定檔名後(這也是你未來的網址名稱)就可以上傳至shinyapps.io了

F16_4